home *** CD-ROM | disk | FTP | other *** search
/ MacWorld UK 2000 March / MW_UK_2000_03.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / AlphaBits.tcl next >
Encoding:
Text File  |  1999-12-05  |  15.2 KB  |  513 lines  |  [TEXT/ALFA]
  1. # First basic initialisation: (works with Alpha 7.2.1 or 8.0 development)
  2. if {[catch {
  3.     if {[info tclversion] < 8.0} {
  4.     ;proc namespace {cmd ns script} {if {$script != ""} {uplevel $script}}
  5.     ;proc variable {n} { global mode ; uplevel 1 [list upvar \#0 $mode::$n $n] }
  6.     ;proc renameMenuItem {args} {}
  7.     } else {
  8.     namespace eval alpha {
  9.         namespace eval index {}
  10.         namespace eval cache {}
  11.     }
  12.     namespace eval win {}
  13.     if {[info commands scancontext] == ""} {
  14.         proc scancontext {cmd args} {
  15.         switch -- $cmd {
  16.             "create" {
  17.             uplevel 1 {
  18.                 set __scan 0
  19.                 while {[array exists scancontext$__scan]} {
  20.                 incr __scan
  21.                 }
  22.                 set scancontext[set __scan]() 1
  23.                 return scancontext$__scan
  24.             }
  25.             }
  26.             "delete" {
  27.             upvar [lindex $args 0] scan
  28.             unset scan
  29.             }
  30.         }
  31.         }
  32.     
  33.         proc scanmatch {scanid regexp script args} {
  34.         if {[string match "-*" $scanid]} {
  35.             set flags $scanid
  36.             set scanid $regexp
  37.             set regexp [list $flags $script]
  38.             set script [lindex $args 0]
  39.         } else {
  40.             set regexp [list -- $regexp]
  41.         }
  42.         upvar $scanid scan
  43.         set scan($regexp) $script
  44.         return $scanid
  45.         }
  46.     
  47.         proc scanfile {scanid fid} {
  48.         upvar $scanid scan
  49.         upvar matchInfo m
  50.         set m(linenum) 0
  51.         set m(offset) 0
  52.         set names [array names scan]
  53.         while {[set count [gets $fid m(line)]] >= 0} {
  54.             incr m(linenum)
  55.             incr m(offset) [expr {$count +1}]
  56.             foreach reg $names {
  57.             if {$reg == ""} {continue}
  58.             if {[regexp [lindex $reg 0] [lindex $reg 1] $m(line) \
  59.               "" m(submatch0) m(submatch1) m(submatch2)]} {
  60.                 incr m(offset) [expr {-[string length $m(submatch0)]}]
  61.                 uplevel 1 $scan($reg)
  62.                 incr m(offset) [string length $m(submatch0)]
  63.             }
  64.             }
  65.         }
  66.         }
  67.     }
  68.     if {[info commands objDialog] != ""} {
  69.         rename dialog ""
  70.         rename objDialog dialog
  71.     }
  72.     rename lsort __lsort
  73.     proc lsort {args} {
  74.         if {[lindex $args 0] == "-ignore"} {
  75.         eval __lsort -dictionary [lrange $args 1 end]
  76.         } else {
  77.         eval __lsort $args
  78.         }
  79.     }
  80.     # Tcl 8.0 doesn't handle \t \r \n , but Tcl 8.1 will
  81.     if {[info tclversion] == 8.0} {
  82.         rename regexp __regexp
  83.         proc regexp {args} {
  84.         set i 0
  85.         while {[string match -* [set a [lindex $args $i]]]} {
  86.             incr i
  87.             if {$a == "--"} {
  88.             set a [lindex $args $i]
  89.             break
  90.             }
  91.         }
  92.         __regsub -all "\\\\t" $a "\t" a
  93.         __regsub -all "\\\\r" $a "\r" a
  94.         __regsub -all "\\\\n" $a "\n" a
  95.         __regsub -all "\\\\w" $a "\[a-zA-Z0-9_\]" a
  96.         __regsub -all "\\\\s" $a "\[ \t\r\n\]" a
  97.         uplevel __regexp [lreplace $args $i $i $a]
  98.         }
  99.         rename regsub __regsub
  100.         proc regsub {args} {
  101.         set i 0
  102.         while {[string match -* [set a [lindex $args $i]]]} {
  103.             incr i
  104.             if {$a == "--"} {
  105.             set a [lindex $args $i]
  106.             break
  107.             }
  108.         }
  109.         __regsub -all "\\\\" $a "¢¢" a
  110.         __regsub -all "\\\\t" $a "\t" a
  111.         __regsub -all "\\\\r" $a "\r" a
  112.         __regsub -all "\\\\n" $a "\n" a
  113.         __regsub -all "\\\\w" $a "\[a-zA-Z_\]" a
  114.         __regsub -all "\\\\s" $a "\[ \t\r\n\]" a
  115.         __regsub -all "¢¢" $a "\\\\" a
  116.         uplevel __regsub [lreplace $args $i $i $a]
  117.         }
  118.     }
  119.     }    
  120.  
  121.     if {[info tclversion] < 7.6} { 
  122.     set tcl_platform(platform) macintosh
  123.     # Alpha already has these two renamed internally
  124.     # they need their argument packaged as a list!
  125.     ;proc mkdir {dir} {
  126.         oldMkdir [list $dir]
  127.     }
  128.     ;proc rmdir {dir} {
  129.         oldRmdir [list $dir]
  130.     }
  131.     if {[info commands __file] == ""} {
  132.         rename file __file
  133.         ;proc file {cmd args} {
  134.         switch -- $cmd {
  135.             "join" {
  136.             regsub -all "::" [join $args ":"] ":" res
  137.             return $res
  138.             }
  139.             "copy" {eval copyFile $args}
  140.             "rename" {
  141.             if {[catch {eval moveFile $args} err]} {
  142.                 if {$err == "An unknown error occured."} {
  143.                 # Buggy Alpha moveFile
  144.                 set f_to [lindex $args 1]
  145.                 set f_from [lindex $args 0]
  146.                 if {[file exists $f_from] && [file isfile $f_from]} {
  147.                     set contents [file::readAll $f_from]
  148.                     file::writeAll $f_to $contents 1
  149.                     removeFile $f_from
  150.                     return
  151.                 }
  152.                 return -code error "Sorry, moveFile has a\
  153.                   bug.  Please contact the Alpha-D mailing\
  154.                   list for help."
  155.                 } else {
  156.                 return -code error $err
  157.                 }
  158.             }
  159.             }
  160.             "delete" {
  161.             if {[file isdir [lindex $args 0]]} {
  162.                 eval rmdir $args
  163.             } else {
  164.                 eval removeFile $args
  165.             }
  166.             }
  167.             "mkdir" {eval mkdir $args}
  168.             "volumes" {
  169.             # Thanks to Jon
  170.             return [aebuild::result 'MACS' core getd ---- {obj {form:indx, want:type(cdis), seld:abso('all '), from:'null'()}} rtyp TEXT] 
  171.             }
  172.             "split" {
  173.             return [split [lindex $args 0] :]
  174.             }
  175.             "attributes" {
  176.             switch -- [lindex $args 1] {
  177.                 "-readonly" {
  178.                 #__file stat [lindex $args 0] r
  179.                 if {[llength $args] > 2} {
  180.                     # set read-only status
  181.                 } else {
  182.                     # get read-only status
  183.                     return [expr {![__file writable [lindex $args 0]]}]
  184.                 }
  185.                 }
  186.                 default {
  187.                 error "file attributes [lindex $args 1] unimplemented"
  188.                 }
  189.             }
  190.             
  191.             }
  192.             "nativename" {
  193.             return [lindex $args 0]
  194.             }
  195.             "pathtype" {
  196.             # Not a perfect implementation, but not bad.
  197.             set relative 1
  198.             set path [lindex $args 0]
  199.             foreach volume [file volumes] {
  200.                 if {[string first $volume $path] == 0} {
  201.                 unset relative
  202.                 break
  203.                 }
  204.             }
  205.             if {[info exists relative]} {
  206.                 return "relative"
  207.             } else {
  208.                 return "absolute"
  209.             }
  210.             }
  211.             default {uplevel 1 __file $cmd $args}
  212.         }
  213.         }
  214.     }
  215.     } 
  216.  
  217.     # Get Alpha's current name.
  218.     regexp {"([^"]+)" "ALFA" } [processes] "" ALPHA
  219.     # Read Alpha's version information
  220.     if {[catch [list source [file join $HOME Tcl SystemCode alphaVersionInfo.tcl]] err]} {
  221.     alertnote "There was a bad problem while sourcing alphaVersionInfo.tcl"
  222.     error $err
  223.     }
  224.     # PREFS points to a folder 'Alpha', we add the major version number
  225.     append PREFS "-v[lindex [split ${alpha::version} .] 0]"
  226.  
  227.     if {[info commands startupText] != ""} {
  228.     set for ""
  229.     regexp { for [^ ,]+} [version] for
  230.     startupText "Alpha$for $alpha::version, AlphaTcl $alpha::tclversion, Tcl [info patchlevel]"
  231.     unset for
  232.     }
  233.     if {![info exists alpha::modifier_keys]} {
  234.     set alpha::modifier_keys [list "Command" "cmd" "Option" "opt"]
  235.     }
  236.  
  237.     # check if the user over-rides things
  238.     if {[file exists [file join ${HOME} AlphaPrefs]] \
  239.       && [file isdir [file join ${HOME} AlphaPrefs]]} {
  240.     set PREFS [file join ${HOME} AlphaPrefs]
  241.     } else {        
  242.     if {![file exists $PREFS]} { 
  243.         if {[catch {file mkdir $PREFS}]} {
  244.         alertnote "I cannot locate or create your preferences\
  245.           directory '$PREFS'.  From now on I'll try to use \
  246.           '[file join ${HOME} AlphaPrefs]' instead."
  247.         set PREFS [file join ${HOME} AlphaPrefs]
  248.         if {![file exists $PREFS]} { 
  249.             if {[catch {file mkdir $PREFS}]} {
  250.             alertnote "Sorry, I couldn't make '$PREFS'.  Alpha\
  251.               requires a preferences directory to run.  Please fix\
  252.               this problem and then try to rerun Alpha.  Goodbye."
  253.             quit
  254.             }
  255.         }
  256.         }
  257.     }
  258.     }
  259.     set alpha::noMenusYet 1
  260.     set alpha::changingMode 0
  261.     if {$tcl_platform(platform) == "macintosh" && [info tclversion] > 8.0} {
  262.     if {"\u0192" != "ƒ"} {
  263.         if {![file exists [file join [info library] encoding]]} {
  264.         alertnote "Your 'encoding' directory inside Tcl's library\
  265.           '[info library]' doesn't seem to exist.  This will\
  266.           probably cause serious problems."
  267.         } else {
  268.         alertnote "Unknown encoding problem.  Make sure you\
  269.           have installed Tcl properly.  This will\
  270.           probably cause serious problems."
  271.         }
  272.     }
  273.     }
  274.     
  275.     # source v. important code
  276.     if {[catch [list source [file join $HOME Tcl SystemCode library.tcl]] err]} {
  277.     alertnote "There was a bad problem while sourcing library.tcl"
  278.     error $err
  279.     }
  280.     if {[catch [list source [file join $HOME Tcl SystemCode coreFixes.tcl]] err]} {
  281.     alertnote "There was a bad problem while sourcing coreFixes.tcl"
  282.     error $err
  283.     }
  284.     set auto_path {}
  285.     if {[catch [list alpha::makeAutoPath 0 $skipPrefs] err]} {
  286.     alertnote "There was a bad problem while making the autopath"
  287.     error $err
  288.     }
  289.     # Check whether we are likely to have some bad problems
  290.     # usually caused by corrupt/badly out of date Tcl
  291.     # indices, or a bad/partial installation.
  292.     set err [expr {![auto_load cache::readContents]}]
  293.     
  294.     # IMPORTANT: it is vital we get to this point in the startup sequence
  295.     # without any errors.  From this point on if we hit any errors, we
  296.     # should be able to handle them reasonably gracefully, although
  297.     # even then we might force/ask the user to quit.  However errors prior
  298.     # to this point probably can't even be dealt with in a useful way,
  299.     # basically because we only load the 'unknown' procedure just above.
  300.  
  301.     # get known packages
  302.     catch {cache::readContents index::feature}
  303.     # if configuration has changed, rebuild indices
  304.     if {$err || ([catch {alpha::checkConfiguration} err] || ($err == 1))} {
  305.     alertnote "You have recently installed or upgraded Alpha. \
  306.       This means I have to rebuild the index of all available\
  307.       packages, which will take a little while."
  308.     # For safety's sake:
  309.     source [file join $HOME Tcl SystemCode CorePackages cache.tcl]
  310.     source [file join $HOME Tcl SystemCode CorePackages fileManipulation.tcl]
  311.     source [file join $HOME Tcl SystemCode stringsLists.tcl]
  312.     source [file join $HOME Tcl SystemCode modes.tcl]
  313.     source [file join $HOME Tcl SystemCode package.tcl]
  314.     source [file join $HOME Tcl SystemCode CorePackages error.tcl]
  315.     if {[info tclversion] < 8.0} {
  316.         # so 'file volumes' works
  317.         source [file join $HOME Tcl SystemCode CorePackages aebuild.tcl]
  318.         source [file join $HOME Tcl SystemCode CorePackages aeparse.tcl]
  319.         source [file join $HOME Tcl SystemCode CorePackages aecoerce.tcl]
  320.     }
  321.     # power-user can use 'option' to avoid the rebuild
  322.     if {!([getModifiers] & 72)} {
  323.         if {[catch {alpha::makeIndices} err]} {
  324.         alertnote "There was a bad problem while making the package indices."
  325.         alertnote $err
  326.         error $err
  327.         }
  328.         if {[catch {rebuildTclIndices} err]} {
  329.         alertnote "There was a bad problem while making the tcl indices."
  330.         alertnote $err
  331.         error $err
  332.         }
  333.         # For debugging
  334.         #listpick $auto_path
  335.     }
  336.     }
  337.     unset err
  338.  
  339.     if {[alpha::package vcompare ${alpha::version} 7.2d1] < 0} {
  340.     alertnote "This version of Alpha is too old.\
  341.       Upgrade from\
  342.       http://alpha.olm.net/ or\
  343.       ftp://ftp.ucsd.edu/pub/alpha/ \
  344.       \r\rI'll quit now."
  345.     quit
  346.     }
  347.     # load the list of active packages from special cache
  348.     namespace eval global {}
  349.     if {!$skipPrefs} {
  350.     catch {cache::readContents configuration}
  351.     catch {unset mode::defaultfeatures}
  352.     }
  353.     if {![info exists global::features]} {
  354.     set global::features ""
  355.     }
  356.  
  357. # Now do all the more complex stuff:
  358. # (from now on, avoid use of 'source'.  Prefer to use auto-loading)
  359.  
  360.     # pull in smarterSource and internationalMenus packages
  361.     # if the user activated them
  362.     lappend alpha::earlyPackages smarterSource internationalMenus
  363.     alpha::package require Alpha
  364.     foreach pkg [set alpha::earlyPackages] {
  365.     if {[lsearch -exact ${global::features} $pkg] != -1} {
  366.         alpha::package require $pkg
  367.     }
  368.     }
  369.     unset pkg
  370.     # So we can handle times properly
  371.     alpha::package require isoTime
  372.     
  373.     set alpha::packagesAlwaysOn [list Alpha AlphaTcl isoTime]
  374.     
  375.     removeTemporaryFiles
  376.     alpha::getDefinitions
  377.     if {![llength ${global::features}]} {
  378.     lappend global::features internationalMenus filesetMenu
  379.     if {$tcl_platform(platform) == "macintosh"} {
  380.         lappend global::features internetConfigMenu eudoraMenu
  381.     }
  382.     if {!$skipPrefs} {
  383.         if {[dialog::yesno "Alpha contains a lot of useful additional functionality\
  384.           in the form of menus, packages and features.  Many of these provide\
  385.           basic things like completions, a recent files menu, keyboard macros,\
  386.           electric code insertion...\r\r  Would you like me to activate\
  387.           the standard feature set?  (Either\
  388.           way you can turn them on and off using the\
  389.           'Config->Preferences->Menus And Features' menu item)"]} {
  390.         lappend global::features recentFilesMenu elecCompletions \
  391.           elecExpansions macros elecBindings emacs autoContinueComment
  392.         }
  393.     }
  394.     }
  395.     if {!$skipPrefs} {
  396.     # Read both scalar and array definitions from preferences folder.
  397.     prefs::readAll
  398.     if {[key::optionPressed]} {
  399.     }
  400.     }
  401.     # define v. important keyboard variables
  402.     keys::keyboardChanged
  403.     message "Building basic menus…"
  404.     menu::buildBasic
  405.     message "Binding keys…"
  406.     if {![info exists alpha::haveBasicKeys]} {
  407.     alpha::basicKeyBindings
  408.     }
  409.     alpha::keyBindings
  410.     alpha::useElectricTemplates
  411.     # Read in all packages, modes and menus.
  412.     message "Reading in packages…"
  413.     alpha::findAllPlugins
  414.     if {!$skipPrefs} {
  415.     # read preferences file
  416.     if {[catch {prefs::tclRead} err]} {
  417.         append alpha::errorLog "\r" $err
  418.         unset err
  419.     }
  420.     }
  421.     # call anything that's attached to my keyboard.
  422.     hook::callAll keyboard $keyboard
  423.     message "Building complete menus…"
  424.     # build all menus completely.
  425.     alpha::buildMainMenus
  426.     # insert menus
  427.     global::insertAllMenus
  428.     # Bind special keys
  429.     bind::fromArray keys::specialBindings keys::specialProcs
  430.  
  431. # if we do anything else to a menu, it must now be rebuilt
  432. unset alpha::noMenusYet
  433.  
  434. # couple of random things
  435. alpha::makeColourList
  436.  
  437. # Add to chars considered part of words.
  438. addAlphaChars {_ÄÅÇÉÑÖÜáàâäãåçéèêëíìîïñóòôöõúùûüÅØæøæß}
  439. # Call all startup hooks
  440. hook::callAll startupHook *
  441. # Alerts and readme's for the user:
  442.  
  443.     if {!$skipPrefs} {
  444.     if {![info exists readReadme] \
  445.       || ([lindex $readReadme 0] != [alpha::package versions Alpha]) \
  446.       || ([lindex $readReadme 1] != [alpha::package versions AlphaTcl]) \
  447.     } {
  448.         prefs::add readReadme [list [alpha::package versions Alpha] \
  449.           [alpha::package versions AlphaTcl]]
  450.         if {[llength [set files [glob -nocomplain -path \
  451.           [file join $HOME Help Readme] *]]]} {
  452.         foreach f $files {
  453.             edit -r $f
  454.         }
  455.         unset f
  456.         unset files
  457.         } else {
  458.         alertnote "Alpha's readme file should be in\
  459.           '[file join $HOME Help]', but isn't.  You may wish\
  460.           to reinstall Alpha."
  461.         }
  462.     } else {unset readReadme}
  463.     
  464.     if {[info exists alpha::readAtStartup]} {
  465.         foreach f ${alpha::readAtStartup} {
  466.         catch {edit -r $f}
  467.         }
  468.         unset alpha::readAtStartup
  469.         lappend modifiedVars alpha::readAtStartup
  470.     }
  471.     }
  472.  
  473. } err]} {
  474.     append alpha::errorLog "\r" $errorInfo
  475.     set errCache $errorInfo
  476.     if {![auto_load dialog::yesno] || ![auto_load dialog::alert]} {
  477.     # This error happened either too early on in a weird way,
  478.     # so that even the auto-loading mechanism doesn't work
  479.     # (and has overwritten the original problem)
  480.     # We just use the cached information.
  481.     set errorInfo $errCache
  482.     alertnote "That was a core startup error.  Alpha will probably\
  483.       not function correctly.  Press Ok to view the error.  Also note\
  484.       that auto-loading seems not to be functioning."
  485.     if {[info tclversion] < 8.0} {
  486.         alertnote [string range $errorInfo 0 250]
  487.     } else {
  488.         alertnote $errorInfo
  489.     }
  490.     } else {
  491.     if {[dialog::yesno -y "View the error" -n "Continue" \
  492.       "That was a core startup error.  Alpha will probably\
  493.       not function correctly."]} {
  494.         dialog::alert $errorInfo
  495.     }
  496.     }
  497. }
  498. if {[info exists alpha::errorLog]} {
  499.     catch {
  500.     new -n "* Alpha startup error log *" -info ${alpha::errorLog}
  501.     unset alpha::errorLog
  502.     }
  503. }
  504. # call these two procs to sort out the menu enabled state.
  505. catch {
  506.     menuEnableHook [expr {[win::Current] != ""}]
  507.     requireOpenWindowsHook 2
  508. }
  509. message "Initialization Complete"
  510.  
  511.  
  512.  
  513.